CD ROM Paradise Collection 4/CD ROM Paradise Collection 4 1995 Nov.iso/program/tjgold.zip/INSTALL.001/GOLDNDX.INC

Text File | 1995-07-19 | 22KB | 721 lines

{--------------------------------------------------------------------------}
{                Product: TechnoJock's Turbo Toolkit                       }
{                Version: GOLD                                             }
{                Build:   1.01                                             }
{                                                                          }
{  The index routines used in TTT Gold were developed by Dean Farwell II   }
{  and are an adaptation of his excellent TBTREE database tools.           }
{                                                                          }
{                   Copyright 1988-1994 Dean Farwell II                    }
{        Portions Copyright 1986-1995  TechnoJock Software, Inc.           }
{                           All Rights Reserved                            }
{                          Restricted by License                           }
{--------------------------------------------------------------------------}

                     {********************************}
                     {       Include: GOLDNDX         }
                     {********************************}

const
    NDXERROROFFSET = 2000;

type                       { keeps current info regarding search in progress }
    FindRecord = Record
        valid: Boolean;
        partial: Boolean;
        fieldNo: Integer;
        vType:  ValueType;
        lrNum: LrNumber;
        findValue: ValueArray;
        end;

var fRecord : FindRecord;
    ndxUpperCaseFlag : Boolean;

procedure InitializeFindRecord;

    begin
    with fRecord do
        begin
        valid := FALSE;
        partial := FALSE;
        fieldNo := 0;
        vType := INVALIDVALUE;
        lrNum := 0;
        FillChar(findValue,SizeOf(findValue),0);
        end;
    end;


procedure NdxInit;

    begin
    InitializeFindRecord;
    NdxSetUpperCase(TRUE);
    NdxSetMaxPages(25);
    end;


function NdxErrorOccurred(NdxName : PathStr) : Boolean;
{ Checks for error which occurred accessing BTree routines
  Releases all pages from buffer for file if error occured }

    begin
    if BTreeErrorOccurred then
        begin
        DBSetError(GetBTreeError + NDXERROROFFSET);
        NdxErrorOccurred := TRUE;
        ReleaseAllPages(NdxName);
        SetBTreeError(0);
        end
    else
        NdxErrorOccurred := FALSE;
    end;


function GetValueType(fieldNo : Integer) : ValueType;
{Returns the ValueType for the given field

          'C' --> STRINGVALUE
          'L' --> BYTEVALUE
          'D' --> LONGINTVALUE
          'N' --> STRING (If Real)
          'N' --> LONGINTVALUE (If Byte/Integer/Long Integer) }

var
    fdType : Char;

    begin
    fdType := DBGetFldType(fieldNo);
    if fdType = 'C' then GetValueType := STRINGVALUE else
    if fdType = 'L' then GetValueType := BYTEVALUE else
    if fdType = 'D' then GetValueType := LONGINTVALUE else
    if DbGetFldDec(fieldNo) = 0 then                          (* must be 'N' *)
        GetValueType := LONGINTVALUE
    else
        GetValueType := STRINGVALUE;
    end;


function CalculateIndexFieldLength(fLength : Byte;
                                   vType : ValueType) : VSizeType;
{ Returns The Field Length In Bytes For Each index Entry }

var
    vSize : VSizeType;

    begin

    case vType of
        STRINGVALUE  :
            if (MaxNdxStrLen = 0) or (MaxNdxStrLen >= fLength + 1) then
                vSize := fLength + 1
            else
                vSize := MaxNdxStrLen;
        LONGINTVALUE : vSize := LONGINTSIZE;
        BYTEVALUE    : vSize := BYTESIZE;
        end;
    CalculateIndexFieldLength := vSize;
    end;


procedure GetDBValue(lrNum : LrNumber;
                     fieldNo : Integer;
                     var dbValue);

var
    dbStr : String absolute DBValue;
    dbByte : Byte absolute DBValue;
    dbLongInt : LongInt absolute DBValue;
    dbDate : Dates absolute DBValue;
    fdType : Char;

    begin
    fdType := DBGetFldType(fieldNo);
    case fdType of
       'C': dbStr := DBGetFldString(lrNum,fieldNo);
       'L': dbByte := Byte(DBGetFldLogical(lrNum,fieldNo));
       'D': dbDate  := DBGetFldDate(lrNum,fieldNo);
       'N': begin
               if DbGetFldDec(fieldNo) = 0 then                      (* must be 'N' *)
                  dbLongInt := DBGetFldLong(lrNum,fieldNo)
               else
                  dbStr := DBGetFldString(lrNum,fieldNo);
            end;

    end;
end;

function MeetsFindCriteria(var value2) : Boolean;

var
    compareResult : Comparison;
    tempStr1  : String;
    tempStr2 : String absolute value2;


    begin
    CompareResult := CompareValues(fRecord.findValue,value2,fRecord.vType);

    if fRecord.partial then
        begin
        if fRecord.vType = STRINGVALUE then
            begin
            Move(fRecord.findValue,tempStr1,fRecord.findValue[1]+1);
            if tempStr1 = Copy(tempStr2,1,Length(tempStr1)) then
                MeetsFindCriteria := TRUE
            else
                MeetsFindCriteria := FALSE;
            end
        else
            MeetsFindCriteria := FALSE;{not valid to do partial on
                                        anything but strings}
        end
    else
        MeetsFindCriteria := compareResult = EQUALTO;
    end;


function UpperCase(var str) : String;

{ Returns Uppercase equivalent of a string.  Any characters in the string
  other than 'a' .. 'z' are unaffected }

var
    cnt : Byte;
    oldStr : String absolute str;
    newStr : String;
    byteArr : Array [0 .. 255] of Char absolute NewStr;

    begin
    newStr := oldStr;
    for cnt := 1 to Length(oldStr) do
        begin
        byteArr[cnt] := UpCase(byteArr[cnt]);
        end;
    UpperCase := newStr;
    end;


procedure NdxBuild(FieldNo: integer; var DF : PathStr;
                   fLength: Byte; FdType: Char);
{ Builds an index file.  Index can exist when this is called, but index
  file must be CLOSED!!!  It creates or rewrites the index file, initializes
  so that it is ready to accept values, and closes it}

var
    lrNum : LrNumber;
    vType : ValueType;
    NdxAlias : File;
    NdxName : PathStr;
    eCode : Integer;

begin
    with DbVars.ActiveNode^.DBInfo do
        begin
        IndexField := 0;
        if NdxBuildNew(FieldNo) <> 0 then {error has been set already};
        end;
    end; { NdxBuild }


function NdxBuildNew(FieldNo: integer): integer;
{ Builds an index file for the given field.  If index exists, the current index
  deleted and replaced by the new index.  This routine can be called whether
  index currently exists or not.  It can also be called with the same field as
  is currently indexed.  In this latter case, it is the same as calling
  RebuildIndex. }

var
    vType : ValueType;
    lrNum : LrNumber;
    dbValue : ValueArray;
    eCode : Integer;
    NumRecs: longint;
    upperStr : String;
begin
    NdxBuildNew := 1;  {assume error in case or early exit}
    if (FieldNo < 1) or (FieldNo > DbTotalFields) then
    begin
       DBSetError(3001);
       exit;
    end;
    with DbVars.ActiveNode^.DBInfo do
    begin
        if IndexField > 0 then                { check to see if index exists }
        begin                           {clear the ndx field value buffer}
           if NdxSpc <> nil then
           begin
              freemem(NdxSpc,NdxFldLen);
              NdxSpc := nil;
           end;
        end
        else
        begin
            NdxName := DbfName;
            Delete(NdxName,Pos('.',DbfName),4);
            NdxName := NdxName + IFX;
            Assign(NdxAlias,NdxName);
        end;

        ReleaseAllPages(NdxName);  (* Put here for safety to ensure buffer is
                                      purged of any records from this index  *)
        {$I-}
        Rewrite(NdxAlias,PAGESIZE);
        eCode := IOResult;
        {$I+}
        if eCode <> 0 then
        begin
           DBSetError(eCode + NDXERROROFFSET);
           exit;
        end;

        IndexField := FieldNo;
        NdxFldLen := DBGetFldLength(IndexField);
        vType := GetValueType(IndexField);

        CreateIndexFile(NdxName,
                        NdxAlias,
                        CalculateIndexFieldLength(NdxFldLen,vType),
                        vType,
                        FieldNo,
                        ndxUpperCaseFlag);

        if NdxErrorOccurred(NdxName) then
           exit;
        SaveIndexFldValue := false;
        IndexUpperCase := NdxUpperCaseFlag;
        NumRecs := DbGetNumRecs;
        DBVars.ShowNdxProgress(lrNum,NumRecs,0);
        for lrNum := 1 to NumRecs do
        begin
            if DBRecordIsActive(lrNum) then
            begin
                GetDBValue(lrNum,IndexField,dbValue);
                if (vType = STRINGVALUE) and indexUpperCase then
                begin
                   upperStr := UpperCase(dbValue);
                   InsertValueInBTree(NdxName,NdxAlias,lrNum,upperStr);
                end
                else
                   InsertValueInBTree(NdxName,NdxAlias,lrNum,dbValue);
                if NdxErrorOccurred(NdxName) then
                   exit;
           end;
           DBVars.ShowNdxProgress(lrNum,NumRecs,1);
        end;
        DBVars.ShowNdxProgress(lrNum,NumRecs,2);
        SaveIndexFldValue := true;
        NdxBuildNew := 0;
   end;
end; { NdxBuildNew }


function NdxReBuild: integer;
{  Rebuilds an EXISTING index file.  It rewrites the index file, initializes
   so that it is ready to accept values, and sets the appropriate fields in
   DBInfo record.  The file is left open.}

    begin
    with DbVars.ActiveNode^.DBInfo do
        NdxReBuild := NdxBuildNew(IndexField);    (* NdxBuildNew will do error handling    *)
    end; { NdxReBuild }

procedure NdxAddKey;
{Inserts value into index for the current indexed field for the current record.
 Record and indexed field within record must be valid. }

var
    lrNum : LrNumber;
    dbValue : ValueArray;
    upperStr : String;

    begin
    with DbVars.ActiveNode^.DBInfo do
        begin
        lrNum := DbCurrRecNum;
        GetDBValue(lrNum,IndexField,dbValue);
        if (GetValueType(IndexField) = STRINGVALUE) and indexUpperCase then
            begin
            upperStr := UpperCase(dbValue);
            InsertValueInBTree(NdxName,NdxAlias,lrNum,upperStr);
            end
        else
            InsertValueInBTree(NdxName,NdxAlias,lrNum,dbValue);

        if NdxErrorOccurred(NdxName) then Exit;
        end;
    end; { NdxAddKey }

procedure NdxDelKey(RecNum : LongInt);
{Deletes value from index for the indexed field within the current record. }

var
    dbValue : ValueArray;
    upperStr : String;

    begin
    with DbVars.ActiveNode^.DBInfo do
        begin
        GetDBValue(RecNum,IndexField,dbValue);
        if (GetValueType(IndexField) = STRINGVALUE) and indexUpperCase then
            begin
            upperStr := UpperCase(dbValue);
            DeleteValueFromBTree(NdxName,NdxAlias,RecNum,upperStr);
            end
        else
            DeleteValueFromBTree(NdxName,NdxAlias,RecNum,dbValue);

        if NdxErrorOccurred(NdxName) then Exit;
        end;
    end; { NdxDelKey }


function DbFindFirst(FieldNo : integer;
                     var FindValue;
                     PartialMatch: boolean): LongInt;
{ Returns the record number for the first record in the index or in the file
  which meets the given criteria.  If the FieldNo specified is the indexed
  field, the index will be used.

  For anything but a string, it must be a perfect match.
  A partail match is possible for strings if PartialMatch is TRUE.  In this
  case, 'jone' is a partial match for 'jones'.

  Internal notes - If the index is used, the cursor is left on the entry past
  the one returned.  This is to help alleviate problems if the entry at the
  cursor is deleted. }

var
    targetValue : ValueArray;
    done : Boolean;
    dummy : LrNumber;
    upperStr : String;

    begin
    fRecord.valid := TRUE;
    fRecord.partial := PartialMatch;
    fRecord.fieldNo := FieldNo;
    fRecord.vType := GetValueType(FieldNo);

    with DbVars.ActiveNode^.DBInfo do
        begin
        if (fRecord.vType = STRINGVALUE) and indexUpperCase then
            begin
            upperStr := UpperCase(FindValue);
            Move(upperStr,
                 fRecord.findValue,
                 CalculateIndexFieldLength(DBGetFldLength(FieldNo),
                 fRecord.vType));
            end
        else
            Move(FindValue,
                 fRecord.findValue,
                 CalculateIndexFieldLength(DBGetFldLength(FieldNo),
                                           fRecord.vType));

        if fRecord.fieldNo = IndexField then
            begin
            fRecord.lrNum := UsingCursorAndGEValueGetLr(NdxName,
                                                        NdxAlias,
                                                        fRecord.findValue,
                                                        fRecord.partial);
            if NdxErrorOccurred(NdxName) then Exit;

            if fRecord.lrNum <> 0 then
                begin
                UsingCursorGetCurrValue(NdxName,NdxAlias,targetValue);
                if NdxErrorOccurred(NdxName) then Exit;
                if not MeetsFindCriteria(targetValue) then
                    fRecord.lrNum := 0;
                dummy := UsingCursorGetNextLr(NdxName,NdxAlias);
                if NdxErrorOccurred(NdxName) then Exit;
                end;
            end
        else
            begin            (* Index won't help .. look through entire file *)
            fRecord.lrNum := 0;
            done := (DBGetNumRecs < 1);
            while not done do
                begin
                Inc(fRecord.lrNum);
                if DbRecordIsActive(fRecord.lrNum) then
                    begin
                    GetDBValue(fRecord.lrNum,FieldNo,targetValue);
                    if MeetsFindCriteria(targetValue) then
                        done := TRUE
                    else
                        if fRecord.lrNum >= DBGetNumRecs then
                            begin
                            done := TRUE;
                            fRecord.lrNum := 0;
                            end;
                    end;
                end;
            end;
        end;
    fRecord.valid := fRecord.lrNum <> 0;
    DbFindFirst := fRecord.lrNum;
    end; { DbFindFirst }


function DBFindNext: Longint;
{}

var
    targetValue : ValueArray;
    done : Boolean;
    dummy : LrNumber;

    begin
    if not fRecord.valid then
        begin
        DBFindNext := 0;
        Exit;
        end;

    with DbVars.ActiveNode^.DBInfo do
        begin
        if fRecord.fieldNo = IndexField then
            begin
            fRecord.lrNum := UsingCursorGetCurrLr(NdxName,NdxAlias);
            if NdxErrorOccurred(NdxName) then Exit;

            if fRecord.lrNum <> 0 then
                begin
                UsingCursorGetCurrValue(NdxName,NdxAlias,targetValue);
                if NdxErrorOccurred(NdxName) then Exit;
                if not MeetsFindCriteria(targetValue) then
                    fRecord.lrNum := 0;
                dummy := UsingCursorGetNextLr(NdxName,NdxAlias);
                if NdxErrorOccurred(NdxName) then Exit;
                end;
            end
        else
            begin            (* Index won't help .. look through entire file *)
            done := FALSE;
            while not done do
                begin
                Inc(fRecord.lrNum);
                if DbRecordIsActive(fRecord.lrNum) then
                    begin
                    GetDBValue(fRecord.lrNum,fRecord.fieldNo,targetValue);
                    if MeetsFindCriteria(targetValue) then
                        done := TRUE
                    else
                        if fRecord.lrNum >= DBGetNumRecs then
                            begin
                            done := TRUE;
                            fRecord.lrNum := 0;
                            end;
                    end;
                end;
            end;
        end;
    fRecord.valid := fRecord.lrNum <> 0;
    DbFindNext := fRecord.lrNum;
    end; { DbFindNext }


function NdxGotoFirst: longint;
{}

    begin
    fRecord.valid := TRUE;
    fRecord.partial := FALSE;
    fRecord.fieldNo := 0;

    with DbVars.ActiveNode^.DBInfo do
        begin
        fRecord.lrNum := UsingCursorGetFirstLr(NdxName,NdxAlias);
        if NdxErrorOccurred(NdxName) then Exit;
        NdxGotoFirst := fRecord.lrNum;
        end;
    end; { NdxGotoFirst }

function NdxGotoLast: longint;
{}

    begin
    fRecord.valid := TRUE;
    fRecord.partial := FALSE;
    fRecord.fieldNo := 0;

    with DbVars.ActiveNode^.DBInfo do
        begin
        fRecord.lrNum := UsingCursorGetLastLr(NdxName,
                                              NdxAlias);
        if NdxErrorOccurred(NdxName) then Exit;
        NdxGotoLast := fRecord.lrNum;
        end;
    end; { NdxGotoLast }

function NdxGotoNext: longint;
{}

    begin
    fRecord.valid := TRUE;
    fRecord.partial := FALSE;
    fRecord.fieldNo := 0;

    with DbVars.ActiveNode^.DBInfo do
        begin
        fRecord.lrNum := UsingCursorGetNextLr(NdxName,
                                              NdxAlias);
        if NdxErrorOccurred(NdxName) then Exit;
        NdxGotoNext := fRecord.lrNum;
        end;
    end; { NdxGotoNext }


function NdxGotoPrev: longint;
{}
    begin
    fRecord.valid := TRUE;
    fRecord.partial := FALSE;
    fRecord.fieldNo := 0;

    with DbVars.ActiveNode^.DBInfo do
        begin
        fRecord.lrNum := UsingCursorGetPrevLr(NdxName,NdxAlias);
        if NdxErrorOccurred(NdxName) then Exit;
        NdxGotoPrev := fRecord.lrNum;
        end;
    end; { NdxGotoPrev }


function NdxGetRecNum(EntryNum : LongInt) : LongInt;

    begin
    with DbVars.ActiveNode^.DBInfo do
        begin
        NdxGetRecNum := GetBTreeEntryLr(NdxName,NdxAlias,EntryNum);
        if NdxErrorOccurred(NdxName) then Exit;
        end;
    end; { NdxGetRecNum }

function NdxValidate(Partial : Boolean): Byte;
{ This routine will perform a partial or a full validation of an index file.
  (depending on the value of the variable Partial).  A partial check will
  validate that the header record is intact and that the file structure
  is valid.  A full validation will perform an additional check to ensure
  that the data file and the index file are synchronized. The routine will
  return one of the following values:

              0 : No errors
             -1 : Header error
             -2 : File error
             -3 : Index and data files not synchronized }
var
    dbRecCnt,
    lrNum : LrNumber;
    compareResult : Comparison;
    indexValue,
    dBValue : ValueArray;
    vType : ValueType;
    result : Byte;

    begin
    with DbVars.ActiveNode^.DBInfo do
        begin
        result := Byte(ValidateBTree(NdxName,NdxAlias));
        if NdxErrorOccurred(NdxName) then Exit;

        if (result <> 0) or Partial then
            begin
            NdxValidate := result;
            end
        else
            begin
            vType := GetValueType(IndexField);
            lrNum := UsingCursorGetFirstLr(NdxName,NdxAlias);
            if NdxErrorOccurred(NdxName) then Exit;

            while lrNum <> 0 do
                begin
                UsingCursorGetCurrValue(NdxName,NdxAlias,indexValue);
                if NdxErrorOccurred(NdxName) then Exit;
                GetDBValue(lrNum,
                           indexField,
                           dbValue);
                compareResult := CompareValues(indexValue,dbValue,vType);
                if compareResult <> EQUALTO then
                    begin
                    NdxValidate := Byte(IFILEERROR);
                    if NdxErrorOccurred(NdxName) then Exit;
                    Exit;
                    end;
                lrNum := UsingCursorGetNextLr(NdxName,NdxAlias);
                if NdxErrorOccurred(NdxName) then Exit;
                end;

            dbRecCnt := 0;
            for lrNum := 1 to DBGetNumRecs do
                if DBRecordIsActive(lrNum) then
                    Inc(dbRecCnt);

            if IndexEntryCount(NdxName,NdxAlias) = dbRecCnt then
                NdxValidate := Byte(NOERROR)
            else
                NdxValidate := Byte(IFILEERROR);

            end;
        end;
    end; { NdxValidate }

procedure  NdxSetMaxPages(n : Word);
{ n must be 0 .. 1024 }
    begin
    SetMaxBufferPages(n);
    end; { NdxSetPageSize }

procedure  NdxSetUpperCase(x : Boolean);
{ Set to TRUE if you want index entries to be converted to upper case and
  FALSE otherwise.  If index entries are set to upper case, the index is
  case insensitive }

    begin
    ndxUpperCaseFlag := x;
    end; { NdxSetUpperCase }

procedure NdxSetMaxStrLength(n : Byte);
{ if n > 0 and n < 245 then this routine will set the max index string size
  to n.  This represents the maximum number of bytes that an index string
  can occupy.  The number of characters would be one less. }

    begin
    if n > MAXVALSIZE then
        MaxNdxStrLen := MAXVALSIZE
    else
        if n > 0 then
            MaxNdxStrLen := n;
    end;

procedure NdxPrint;

var
    lst : Text;

    begin
    with DbVars.ActiveNode^.DBInfo do
        begin
        Assign(lst,'LPT1');
        Rewrite(lst);
        PrintBTreeInfo(NdxName,NdxAlias,FALSE,lst);
        if NdxErrorOccurred(NdxName) then Exit;
        end;
    end;

function NdxCount : longint;


    begin
    with DbVars.ActiveNode^.DBInfo do
        begin
        NdxCount := IndexEntryCount(NdxName,NdxAlias);
        if NdxErrorOccurred(NdxName) then Exit;
        end;
    end;